home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ADA Programming Guide
/
ADA Programming Guide.iso
/
ada_gnu
/
adainc
/
s-tasuti.adb
< prev
next >
Wrap
Text File
|
1996-01-30
|
25KB
|
768 lines
------------------------------------------------------------------------------
-- --
-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G . U T I L I T I E S --
-- --
-- B o d y --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU Library General Public License as published by the --
-- Free Software Foundation; either version 2, or (at your option) any --
-- later version. GNARL is distributed in the hope that it will be use- --
-- ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- --
-- eral Library Public License for more details. You should have received --
-- a copy of the GNU Library General Public License along with GNARL; see --
-- file COPYING.LIB. If not, write to the Free Software Foundation, 675 --
-- Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
-- This package provides RTS Internal Declarations.
-- These declarations are not part of the GNARLI
with System.Task_Primitives; use System.Task_Primitives;
with System.Compiler_Exceptions;
-- Used for, Tasking_Error_ID
with System.Tasking.Abortion;
-- Used for, Undefer_Abortion,
-- Abort_To_Level
with System.Tasking.Queuing; use System.Tasking.Queuing;
-- Used for, Queuing.Dequeue_Head
with System.Error_Reporting;
-- Used for, Error_Reporting.Assert
package body System.Tasking.Utilities is
------------------
-- Make_Passive --
------------------
-- This is a local procedure
procedure Make_Passive
(T : Utilities.ATCB_Ptr);
-- Record that task T is passive.
------------------------------------
-- Vulnerable_Complete_Activation --
------------------------------------
-- WARNING : Only call this procedure with abortion deferred.
-- That's why the name has "Vulnerable" in it.
procedure Vulnerable_Complete_Activation
(T : ATCB_Ptr;
Completed : Boolean)
is
Activator : ATCB_Ptr;
Error : Boolean;
begin
Activator := T.Activator;
if Activator /= null then
-- Should only be null for the environment task.
-- Decrement the count of tasks to be activated by the
-- activator and wake it up so it can check to see if
-- all tasks have been activated. Note that the locks
-- of the activator and created task are locked here.
-- This is necessary because C.Stage and
-- T.Activation_Count have to be synchronized. This is
-- also done in Activate_Tasks and Init_Abortion. So
-- long as the activator lock is always locked first,
-- this cannot lead to deadlock.
Write_Lock (Activator.L, Error);
Write_Lock (T.L, Error);
if T.Stage = Can_Activate then
T.Stage := Active;
Activator.Activation_Count := Activator.Activation_Count - 1;
Cond_Signal (Activator.Cond);
if Completed then
Activator.Exception_To_Raise :=
Compiler_Exceptions.Tasking_Error_ID;
end if;
end if;
Unlock (T.L);
Unlock (Activator.L);
end if;
end Vulnerable_Complete_Activation;
-- PO related routines
---------------------
-- Check_Exception --
---------------------
procedure Check_Exception is
T : ATCB_Ptr := ID_To_ATCB (Self);
Ex : Compiler_Exceptions.Exception_ID := T.Exception_To_Raise;
begin
T.Exception_To_Raise := Compiler_Exceptions.Null_Exception;
Compiler_Exceptions.Raise_Exception (Ex);
end Check_Exception;
-- Rendezvous related routines
-------------------
-- Close_Entries --
-------------------
procedure Close_Entries (Target : Task_ID) is
T : ATCB_Ptr := ID_To_ATCB (Target);
Temp_Call : Entry_Call_Link;
Null_Call : Entry_Call_Link := null;
Temp_Caller : ATCB_Ptr;
TAS_Result : Boolean;
Error : Boolean;
begin
-- Purging pending callers that are in the middle of rendezvous
Temp_Call := T.Call;
while Temp_Call /= null loop
Temp_Call.Exception_To_Raise := Compiler_Exceptions.Tasking_Error_ID;
Temp_Caller := ID_To_ATCB (Temp_Call.Self);
-- Problem: Once this lock is unlocked, the target gan go on to
-- accept other calls, which will be missed by loop. The question
-- is, is there something else that will prevent this???
-- If the target is in an abortion deferred region at this point,
-- I don't know what it would be.
-- By the time we get here, we do know that the target is complete
-- and not callable. Callable is unprotected, but Stage is protected
-- by T.L. If all forms of accept made sure under the protection of
-- T.L that they were not complete before accepting a call, then it
-- should be safe to unlock this here.
-- Problem: what about multiple aborters? If two tasks are in this
-- routine at once, then there could contention if this mutex is
-- unlocked. We need some other form of claim mechanism to prevent
-- this. I think that the mechanism outlined in the implementation
-- sketch, where an aborter waits for a previous aborter to finish
-- its work, might solve this.
-- What if T itself is at exactly this point and gets aborted? In
-- that case, I think that the aborter has to wait for T to finish
-- completing itself. This was previously done by contending for the
-- mutex; it might now have to be done with some kind of flag, or
-- maybe another stage. Perhaps we are setting Stage=Complete too
-- soon, and abortion should wait on that. That would require
-- some other flag to claim the right to complete, however. This
-- flag could probably be protected by T.L; there should not be
-- any need for a TAS or global mutex. Perhaps the Aborting flag
-- could do this, though right now all it means is that an abortion
-- exception has been sent. We really need a separate Completing
-- flag (ugh). On the bright side, this might mean that completion
-- can be treated as once-and-once-only, and need not be reentrant.
-- Problem: What does an acceptor do when it finds that it is being
-- completed? I guess it should wait until completion is finished,
-- just like a second aborter. Otherwise, it might continue on
-- with a rendezvous that it never really accepted.
Write_Lock (Temp_Caller.L, Error);
Temp_Call.Done := True;
Unlock (Temp_Caller.L);
-- The caller can break out of its loop at this point, and never
-- notice the abortion.
-- Temp_Call.Call_Claimed:= False;
-- Wrong, I think. This should look like a completed call to everyone. ???
Abort_To_Level (ATCB_To_ID (Temp_Caller), Temp_Call.Level - 1);
-- I think this might be wrong; Abortion takes precedence over
-- exceptions in the call block. ???
-- Not true; the last call to be canceled won't raise Abortion again;
-- it raises the chosen exception instead. This is true of leaf
-- (suspending) calls as well; they decrement the nesting level
-- before undeferring abortion, which will prevent further abortion
-- (providing that abortion is not to an outer level).
-- Final resolution and removal of these comments, or replacement
-- by comments saying what is happening without speculation
-- is needed (RBKD) ???
Temp_Call := Temp_Call.Acceptor_Prev_Call;
end loop;
-- Purging entry queues
for J in 1 .. T.Entry_Num loop
Dequeue_Head (T.Entry_Queues (J), Temp_Call);
if Temp_Call /= Null_Call then
loop
Test_And_Set (Temp_Call.Call_Claimed'Address, TAS_Result);
if TAS_Result then
Temp_Caller := ID_To_ATCB (Temp_Call.Self);
Temp_Call.Exception_To_Raise :=
Compiler_Exceptions.Tasking_Error_ID;
Temp_Call.Done := True;
Abort_To_Level (
ATCB_To_ID (Temp_Caller), Temp_Call.Level - 1);
else
null;
-- Someone else claimed this call. It must be to cancel it,
-- since the acceptor can't have accepted it at this point.
-- So far as we are concerned, this call is not on the
-- queue, and we don't have to raise tasking error in the
-- caller.
end if;
Dequeue_Head (T.Entry_Queues (J), Temp_Call);
exit when Temp_Call = Null_Call;
end loop;
end if;
end loop;
end Close_Entries;
----------------------------
-- Complete_On_Sync_Point --
----------------------------
procedure Complete_on_Sync_Point (T : Task_ID) is
Target : ATCB_Ptr := ID_To_ATCB (T);
Call : Entry_Call_Link;
TAS_Result : Boolean;
Error : Boolean;
begin
Write_Lock (Target.L, Error);
if Target.Suspended_Abortably then
if Target.Accepting /= Not_Accepting then
Unlock (Target.L);
Complete (T);
else
-- Hopefully suspended on an entry call by elimination.
if Target.ATC_Nesting_Level > ATC_Level_Base'First then
Call := Target.Entry_Calls (Target.ATC_Nesting_Level)'Access;
Test_And_Set (Call.Call_Claimed'Address, TAS_Result);
if TAS_Result then
Unlock (Target.L);
Complete (T);
Call.Call_Claimed := False;
-- To allow abortion to claim it.
else
Unlock (Target.L);
end if;
end if;
end if;
else
Unlock (Target.L);
end if;
end Complete_on_Sync_Point;
--------------------
-- Reset_Priority --
--------------------
procedure Reset_Priority
(Acceptor_Prev_Priority : Rendezvous_Priority;
Acceptor : Task_ID)
is
Acceptor_ATCB : ATCB_Ptr := ID_To_ATCB (Acceptor);
begin
if Acceptor_Prev_Priority /= Priority_Not_Boosted then
Acceptor_ATCB.Current_Priority := Acceptor_Prev_Priority;
Set_Priority
(Acceptor_ATCB.LL_TCB'Access, Acceptor_ATCB.Current_Priority);
end if;
end Reset_Priority;
---------------------------
-- Terminate_Alternative --
---------------------------
-- WARNING : Only call this procedure with abortion deferred. This
-- procedure needs to have abortion deferred while it has the current
-- task's lock locked. Since it is called from two procedures which
-- also need abortion deferred, it is left controlled on entry to
-- this procedure.
procedure Terminate_Alternative is
P, T : ATCB_Ptr := ID_To_ATCB (Self);
Taken : Boolean;
Error : Boolean;
begin
Make_Passive (T);
-- Note that abortion is deferred here (see WARNING above)
Write_Lock (T.L, Error);
T.Terminate_Alternative := true;
while T.Accepting /= Not_Accepting
and then T.Stage /= Complete
and then T.Pending_ATC_Level >= T.ATC_Nesting_Level
loop
Cond_Wait (T.Cond, T.L);
end loop;
if T.Stage = Complete then
Unlock (T.L);
if T.Pending_ATC_Level < T.ATC_Nesting_Level then
Abortion.Undefer_Abortion;
Error_Reporting.Assert (False, "Continuing after being aborted!");
end if;
Abort_To_Level (ATCB_To_ID (T), 0);
Abortion.Undefer_Abortion;
Error_Reporting.Assert (False, "Continuing after being aborted!");
end if;
T.Terminate_Alternative := false;
Unlock (T.L);
end Terminate_Alternative;
--------------
-- Complete --
--------------
procedure Complete (Target : Task_ID) is
T : ATCB_Ptr := ID_To_ATCB (Target);
Caller : ATCB_Ptr := ID_To_ATCB (Self);
Task1 : ATCB_Ptr;
Task2 : ATCB_Ptr;
Error : Boolean;
begin
-- Make_Passive used to be the last thing done in this routine in the
-- original MRTSI code. Make_Passive was modified not to process a
-- completed task, so setting the complete flag conflicted with this.
-- I don't see any reason why the task cannot be made passive before
-- it is marked as completed, but I may find out. ???
Make_Passive (T);
Write_Lock (T.L, Error);
if T.Stage < Completing then
T.Stage := Completing;
T.Accepting := Not_Accepting;
-- *LATER* consider new value of this type ???
T.Awaited_Dependent_Count := 0;
Unlock (T.L);
Close_Entries (ATCB_To_ID (T));
T.Stage := Complete;
-- Wake up all the pending calls on Aborter_Link list
Task1 := T.Aborter_Link;
T.Aborter_Link := null;
while (Task1 /= null) loop
Task2 := Task1;
Task1 := Task1.Aborter_Link;
Task2.Aborter_Link := null;
Cond_Signal (Task2.Cond);
end loop;
else
-- Some other task is completing this task. So just wait until
-- the completion is done. A list of such waiting tasks is
-- maintained by Aborter_Link in ATCB.
while T.Stage < Complete loop
if T.Aborter_Link /= null then
Caller.Aborter_Link := T.Aborter_Link;
end if;
T.Aborter_Link := Caller;
Cond_Wait (Caller.Cond, T.L);
end loop;
Unlock (T.L);
end if;
end Complete;
-- Task_Stage related routines
----------------------
-- Make_Independent --
----------------------
procedure Make_Independent is
T : ATCB_Ptr := ID_To_ATCB (Self);
P : ATCB_Ptr;
Result : Boolean;
Error : Boolean;
begin
Write_Lock (T.L, Error);
P := T.Parent;
Unlock (T.L);
Write_Lock (P.L, Error);
Write_Lock (T.L, Error);
T.Master_of_Task := Master_ID (0);
if P.Awake_Count > 1 then
P.Awake_Count := P.Awake_Count - 1;
end if;
Unlock (T.L);
Unlock (P.L);
Remove_From_All_Tasks_List (T, Result);
Error_Reporting.Assert (Result,
"Failed to delete an entry from All_Tasks_List");
end Make_Independent;
-- Task Abortion related routines
--------------------
-- Abort_To_Level --
--------------------
procedure Abort_To_Level
(Target : Task_ID;
L : ATC_Level)
is
T : ATCB_Ptr := ID_To_ATCB (Target);
Error : Boolean;
begin
Write_Lock (T.L, Error);
if T.Pending_ATC_Level > L then
T.Pending_ATC_Level := L;
T.Pending_Action := True;
if not T.Aborting then
T.Aborting := True;
if T.Suspended_Abortably then
Cond_Signal (T.Cond);
Cond_Signal (T.Rend_Cond);
-- Ugly; think about ways to have tasks suspend on one
-- condition variable. ???
else
if Target = Self then
Unlock (T.L);
Abort_Task (T.LL_TCB'Access);
return;
elsif T.Stage /= Terminated then
Abort_Task (T.LL_TCB'Access);
end if;
-- If this task is aborting itself, it should unlock itself
-- before calling abort, as it is unlikely to have the
-- opportunity to do so afterwords. On the other hand, if
-- another task is being aborted, we want to make sure it is
-- not terminated, since there is no need to abort a terminated
-- task, and it may be illegal if it has stopped executing.
-- In this case, the Abort_Task must take place under the
-- protection of the mutex, so we know that Stage/=Terminated.
end if;
end if;
end if;
Unlock (T.L);
end Abort_To_Level;
-------------------
-- Abort_Handler --
-------------------
procedure Abort_Handler
(Context : Task_Primitives.Pre_Call_State)
is
T : ATCB_Ptr := ID_To_ATCB (Self);
begin
if T.Deferral_Level = 0
and then T.Pending_ATC_Level < T.ATC_Nesting_Level
then
raise Standard'Abort_Signal;
-- Not a good idea; signal remains masked after the Abortion ???
-- exception is handled. There are a number of solutions :
-- 1. Change the PC to point to code that raises the exception and
-- then jumps to the location that was interrupted.
-- 2. Longjump to the code that raises the exception.
-- 3. Unmask the signal in the Abortion exception handler
-- (in the RTS).
end if;
end Abort_Handler;
----------------------
-- Abort_Dependents --
----------------------
-- Process abortion of child tasks.
-- Abortion should be dererred when calling this routine.
-- No mutexes should be locked when calling this routine.
procedure Abort_Dependents (Abortee : Task_ID) is
Temp_T : ATCB_Ptr;
Temp_P : ATCB_Ptr;
Old_Pending_ATC_Level : ATC_Level_Base;
TAS_Result : Boolean;
A : ATCB_Ptr := ID_To_ATCB (Abortee);
Error : Boolean;
begin
Write_Lock (All_Tasks_L, Error);
Temp_T := All_Tasks_List;
while Temp_T /= null loop
Temp_P := Temp_T.Parent;
while Temp_P /= null loop
exit when Temp_P = A;
Temp_P := Temp_P.Parent;
end loop;
if Temp_P = A then
Temp_T.Accepting := Not_Accepting;
-- Send cancel signal.
Complete_on_Sync_Point (ATCB_To_ID (Temp_T));
Abort_To_Level (ATCB_To_ID (Temp_T), 0);
end if;
Temp_T := Temp_T.All_Tasks_Link;
end loop;
Unlock (All_Tasks_L);
end Abort_Dependents;
------------------
-- Make_Passive --
------------------
-- If T is the last dependent of some master in task P to become passive,
-- then release P. A special case of this is when T has no dependents
-- and is completed. In this case, T itself should be released.
-- If the parent is made passive, this is repeated recursively, with C
-- being the previous parent and P being the next parent up.
-- Note that we have to hold the locks of both P and C (locked in that
-- order) so that the Awake_Count of C and the Awaited_Dependent_Count of
-- P will be synchronized. Otherwise, an attempt by P to terminate can
-- preempt this routine after C's Awake_Count has been decremented to zero
-- but before C has checked the Awaited_Dependent_Count of P. P would not
-- count C in its Awaited_Dependent_Count since it is not awake, but it
-- might count other awake dependents. When C gained control again, it
-- would decrement P's Awaited_Dependent_Count to indicate that it is
-- passive, even though it was never counted as active. This would cause
-- P to wake up before all of its dependents are passive.
-- Note : Any task with an interrupt entry should never become passive.
-- Support for this feature needs to be added here.
procedure Make_Passive (T : Utilities.ATCB_Ptr) is
P : Utilities.ATCB_Ptr;
-- Task whose Awaited_Dependent_Count may be decremented.
C : Utilities.ATCB_Ptr;
-- Task whose awake-count gets decremented.
H : Utilities.ATCB_Ptr;
-- Highest task that is ready to terminate dependents.
Taken : Boolean;
Activator : Utilities.ATCB_Ptr;
Error : Boolean;
begin
Utilities.Vulnerable_Complete_Activation (T, Completed => False);
Write_Lock (T.L, Error);
if T.Stage >= Utilities.Passive then
Unlock (T.L);
return;
else
T.Stage := Utilities.Passive;
Unlock (T.L);
end if;
H := null;
P := T.Parent;
C := T;
while C /= null loop
if P /= null then
Write_Lock (P.L, Error);
Write_Lock (C.L, Error);
C.Awake_Count := C.Awake_Count - 1;
if C.Awake_Count /= 0 then
-- C is not passive; we cannot make anything above this point
-- passive.
Unlock (C.L);
Unlock (P.L);
exit;
end if;
if P.Awaited_Dependent_Count /= 0 then
-- We have hit a non-task master; we will not be able to make
-- anything above this point passive.
P.Awake_Count := P.Awake_Count - 1;
if C.Master_of_Task = P.Master_Within then
P.Awaited_Dependent_Count := P.Awaited_Dependent_Count - 1;
if P.Awaited_Dependent_Count = 0 then
H := P;
end if;
end if;
Unlock (C.L);
Unlock (P.L);
exit;
end if;
if C.Stage = Utilities.Complete then
-- C is both passive (Awake_Count = 0) and complete; wake it
-- up to await termination of its dependents. It will not be
-- complete if it is waiting on a terminate alternative. Such
-- a task is not ready to wait for its dependents to terminate,
-- though one of its ancestors may be.
H := C;
end if;
Unlock (C.L);
Unlock (P.L);
C := P;
P := C.Parent;
else
Write_Lock (C.L, Error);
C.Awake_Count := C.Awake_Count - 1;
if C.Awake_Count /= 0 then
-- C is not passive; we cannot make anything above
-- this point passive.
Unlock (C.L);
exit;
end if;
if C.Stage = Utilities.Complete then
-- C is both passive (Awake_Count = 0) and complete; wake it
-- up to await termination of its dependents. It will not be
-- complete if it is waiting on a terminate alternative. Such
-- a task is not ready to wait for its dependents to terminate,
-- though one of its ancestors may be.
H := C;
end if;
Unlock (C.L);
C := P;
end if;
end loop;
if H /= null then
Cond_Signal (H.Cond);
end if;
end Make_Passive;
procedure Remove_From_All_Tasks_List (
Source : Utilities.ATCB_Ptr;
Result : out Boolean) is
C : Utilities.ATCB_Ptr;
P : Utilities.ATCB_Ptr;
Previous : Utilities.ATCB_Ptr;
Error : Boolean;
begin
Write_Lock (Utilities.All_Tasks_L, Error);
Result := False;
Previous := null;
C := Utilities.All_Tasks_List;
while C /= null loop
if C = Source then
Result := True;
if Previous = null then
Utilities.All_Tasks_List :=
Utilities.All_Tasks_List.All_Tasks_Link;
else
Previous.All_Tasks_Link := C.All_Tasks_Link;
end if;
exit;
end if;
Previous := C;
C := C.All_Tasks_Link;
end loop;
Unlock (Utilities.All_Tasks_L);
end Remove_From_All_Tasks_List;
end System.Tasking.Utilities;